home *** CD-ROM | disk | FTP | other *** search
/ PC-Blue - MS DOS Public Domain Library / PC-Blue MS-DOS Public Domain Library - NYACC.iso / vol017 / qqsort.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-01-11  |  4.0 KB  |  183 lines
  1. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  2. {+  PROGRAM TITLE:    Quick sort with minimal storage +}
  3. {+            Test Program            +}
  4. {+                            +}
  5. {+  WRITTEN BY:        Raymond E. Penley        +}
  6. {+  DATE WRITTEN:    October 5, 1980            +}
  7. {+                            +}
  8. {+  A program to show the speed of the quick sort    +}
  9. {+  with minimal storage algorithm.            +}
  10. {+                            +}
  11. {+       Average sorting times in seconds *        +}
  12. {+  No. of items   Shellsort    Quicksort  QQuicksort   +}
  13. {+     1000         15             8          7    +}
  14. {+     2000         34            20         14        +}
  15. {+     5000        112            50         37        +}
  16. {+   10,000        213           106         78        +}
  17. {+                            +}
  18. {+    * Z80 CPU operating at 2 mcps            +}
  19. {+                            +}
  20. {++++++++++++++++++++++++++++++++++++++++++++++++++++++++}
  21. PROGRAM QuickerQuickSortTest;
  22. CONST
  23.   Max_N = 10000;
  24. TYPE
  25.   index = 0..Max_N;
  26.   Scalar = INTEGER;
  27. VAR
  28.   cix    : char;
  29.   N,
  30.   i, ix    : Scalar;
  31.   A    : ARRAY [index] OF Scalar;
  32.  
  33.  
  34. Procedure Show;
  35. var
  36.   i: index;
  37. begin
  38.   for i:=1 to N do
  39.     begin
  40.       write(A[i]);
  41.       if i mod 8 = 0 then writeln;
  42.     end;
  43.   writeln;
  44. end;
  45.  
  46.  
  47.  
  48.  
  49. PROCEDURE QQSORT( left, right : INTEGER );
  50. {
  51. + WRITTEN BY:    Richard C. Singleton
  52. + DATE WRITTEN:    Sept 17, 1968
  53. +
  54. + This procedure sorts the elements of array A[1..n] into
  55.   ascending order.  The method used is similar to QUICKERSORT
  56.   by R.S. Scowen, which in turn is similar to an algorithm given
  57.   by Hibbard and to Hoare's QUICKSORT.
  58. +
  59. + Modified 6 Oct 1980 for Pascal/Z.        +}
  60. {
  61. GLOBAL
  62.   TYPE
  63.     Index  = 1..N;
  64.     Scalar = <Some scalar type>
  65.   VAR
  66.     A : array [Index] of Scalar;
  67. }
  68. VAR
  69.   t, tt: Scalar;
  70.   ii, ij, k, L, m : integer;
  71.   IL, IU : array [0..20] of integer;{Permit sorting up to 2**(K+1)-1 elements}
  72.   i, j, ix    : integer;
  73.   alldone, d : BOOLEAN;
  74. BEGIN                 {$C-,M-,F-}
  75.   i := left;
  76.   j := right;
  77.   m := 0;
  78.   ii := i;
  79.   alldone := FALSE;
  80.   REPEAT
  81.      If ((j-i) > 10) OR ( (i = ii) and (i < j) ) then
  82.        BEGIN
  83.       ij := (i+j) DIV 2;
  84.       t := A[ij];
  85.       k := i;
  86.       L := j;
  87.       If (A[i] > t) then
  88.         begin
  89.           A[ij] := A[i]; A[i] := t; t := A[ij]
  90.         end;
  91.       If (A[j] < t) then
  92.         begin
  93.           A[ij] := A[j]; A[j] := t; t := A[ij];
  94.           If (A[i] > t) then
  95.         begin
  96.           A[ij] := A[i]; A[i] := t; t := A[ij]
  97.         end;
  98.         end;
  99.       d := FALSE;
  100.       REPEAT
  101.         REPEAT
  102.           L := L - 1;
  103.         UNTIL A[L] <= t;
  104.         REPEAT
  105.           k := k + 1;
  106.         UNTIL A[k] >= t;
  107.         If (k <= L) then
  108.           begin
  109.             tt := A[L]; A[L] := A[k]; A[k] := tt;
  110.           end
  111.         Else
  112.           d := TRUE;
  113.       UNTIL d;
  114.       If (L-i) > (j-k) then
  115.         begin  IL[m] := i; IU[m] := L; i := k end
  116.       Else
  117.         begin IL[m] := k; IU[m] := j; j := L end;
  118.       m := m + 1;
  119.        END
  120.      Else
  121.        BEGIN
  122.      For ix := (i+1) to j do
  123.        begin
  124.          t := A[ix];
  125.          k := ix - 1;
  126.          If A[k] > t then
  127.            begin
  128.          REPEAT
  129.            A[k+1] := A[k];
  130.            k := k - 1;
  131.          UNTIL A[k] <= t;
  132.          A[k+1] := t;
  133.            end;
  134.        end;{For ix}
  135.      m := m - 1;
  136.      If m >= 0 then
  137.        begin
  138.          i := IL[m];
  139.          j := IU[m];
  140.        end
  141.          Else
  142.        alldone := TRUE;
  143.        END;
  144.   UNTIL alldone;
  145. END;{of QQSORT}            {$C+,M+,F+}
  146.  
  147. BEGIN (* MAIN *)
  148.   repeat
  149.     writeln;
  150.     writeln('Enter number of items to sort');
  151.     writeln(' 10 <= n <= 10,000');
  152.     write('?');
  153.     readln(N);
  154.   until (N >= 10) and (N <= Max_N);
  155.  
  156.   writeln;
  157.   writeln('Please stand by while I set up.');
  158.   {$C-,M-,F- [ctrl-c OFF]}
  159.   ix := 113;
  160.   FOR i := 1 TO N DO
  161.     BEGIN
  162.       ix := (131*ix+1) mod 221;
  163.       A[i] := ix;
  164.       if (i mod 1000 = 0) then write(i);
  165.     END;
  166.   writeln;
  167.   A[0] := -maxint;            {$C+,M+,F+ [ctrl-c ON]}
  168.  
  169.   writeln('Ready');
  170.   WRITE('Press return when ready to start');
  171.   readln(cix);
  172.   writeln( CHR(7), 'START');
  173.   {}
  174.       QQSORT( 1, N );
  175.   {}
  176.   WRITELN( CHR(7), 'DONE!!!' );
  177.  
  178.   writeln;
  179.   write('Print the array (Y/N)?');
  180.   readln(cix);
  181.   If (cix='Y') or (cix='y') then Show;
  182. END.
  183.